home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / ai.prl / draw.pl < prev    next >
Text File  |  1993-07-21  |  10KB  |  276 lines
  1. /*-----------------------------------------------------------------------------*/
  2. /*  This program was written by Mark Holcomb and is hearby released into the   */
  3. /*  public domain provided this header remains intact.  As usual, no guarantee */
  4. /*  is made as to the correctness of the code, the suitability of this code    */
  5. /*  for any particular application, or that the code will be maintained.       */
  6. /*  USAGE:                                                                     */
  7. /*      The code expects (as input), the tree structure of a sentence in a     */
  8. /*      form similar to:   s(np(d(the),n(dog)),vp(v(ran),np(d(the),n(house)))) */
  9. /*      and prints an ascii diagram of the structure.                          */
  10. /*                                                                             */
  11. /*        eg.  draw(s(np(d(the),n(dog)),vp(v(ran),np(d(the),n(house))))).      */
  12. /*                                           */
  13. /*                       s                                                     */
  14. /*                 |                                                     */
  15. /*          +-----------------+                                                */
  16. /*            np                vp                                               */
  17. /*        |                 |                                                */
  18. /*     +------+      +----------+                                            */
  19. /*     d      n      v          np                                           */
  20. /*     |      |      |          |                                            */
  21. /*     |      |      |      +-------+                                        */
  22. /*     |      |      |      d       n                                        */
  23. /*     |      |      |      |       |                                        */
  24. /*     |      |      |      |       |                                        */
  25. /*      the    dog    ran    the    house                                      */
  26. /*                                                                             */
  27. /*-----------------------------------------------------------------------------*/
  28.  
  29. /* ---- begin draw routine ----------------------------------------------------*/
  30.  
  31. :- ensure_loaded(library(lists)).
  32.  
  33. /* the 5 in add is the constant offset from the left edge of the screen */
  34.  
  35. draw(Struct) :- md(1,Struct,1,Depth),
  36.         add(Depth,Struct,New_struct,5,_),
  37.         Mod is Depth + 1,
  38.         breadth(1,Mod,New_struct).
  39.  
  40. trunc(X,Y) :-
  41.     name(X,NX),
  42.     until_dot(NX,NY),
  43.     rev(NY,RNY),
  44.     name(Y,RNY).
  45.  
  46. until_dot(X,Res) :- until_dot_aux(X,[],Res).
  47. until_dot_aux([],Res,Res) :- !.
  48. until_dot_aux([46|_],Res,Res) :- !.
  49. until_dot_aux([H|T],Sofar,Res) :- until_dot_aux(T,[H|Sofar],Res).
  50.  
  51. append([],X,X).
  52. append([X1|X2],Y,[X1|Z]) :- append(X2,Y,Z).
  53.  
  54. wspaces(0).
  55. wspaces(Num) :- New is Num - 1, write(' '), wspaces(New).
  56.  
  57. spaces(0,Tout,Tout).
  58. spaces(Num,Tin,Tout) :- New is Num - 1,
  59.             append(Tin,[32],Tmid),
  60.             spaces(New,Tmid,Tout).
  61.  
  62. aux_lines(_,_,Max,Max) :- !. /* if this is the last level, don't print |'s */
  63. aux_lines(Out,Begin,_,_) :- lines(Out,Begin).
  64.  
  65. lines([],_).
  66. lines([H|T],Cur) :- New is H - Cur, wspaces(New),
  67.              Next is H + 1,    
  68.             write('|'), lines(T,Next). 
  69.  
  70. size(Term,Size) :- name(Term,List),len(List,Size). 
  71.  
  72. len([],0).
  73. len([_|T],Length) :- len(T,J), Length is J + 1.
  74.  
  75. dummy(~,Tin,Tout) :- !,
  76.                append(Tin,[124],Tout). 
  77.  
  78. dummy(Name,Tin,Tout) :- name(Name,List), append(Tin,List,Tout).
  79.  
  80. prt([]).
  81. prt(List) :- name(Text,List),write(Text).
  82.  
  83. post(0,_) :- !.
  84. post(1,_) :- !. 
  85. post(_,Dout) :- prt(Dout).
  86.  
  87. end([],[],[]):- !. /* empty list sent to end */
  88. end([H],[],H) :- !,atomic(H). /* one element list */
  89. end([H|T],[H|Out],End) :- end(T,Out,End).
  90.  
  91. cross(2,Din,Dout,Chars) :- !, single(Din,Dout,Chars).
  92. cross(_,Din,Dout,Chars) :- aux_cross(Din,Dout,Chars).
  93.  
  94. ifs([],Dout,Dout) :- !.
  95. ifs(32,Dout,Dout) :- !,nl,write('Error: blank end in ifs ').
  96. ifs(End,Din,Dout) :- append(Din,[End],Dout).
  97.  
  98.  
  99. single(Din,Dout,Chars) :- end(Din,Dmid,End),
  100.                       /* if [] add char - 1 spaces
  101.                          if + append + and char - 1 spaces
  102.                          if | append | and char - 1 spaces 
  103.                          if anything else, I messed up */
  104.             ifs(End,Dmid,Dmid2),
  105.             New is Chars - 1,
  106.             spaces(New,Dmid2,Dmid3),
  107.             append(Dmid3,[124],Dout). /* add a '|' to Dout */
  108.  
  109. dashes(0,Dout,Dout) :- !.
  110. dashes(Num,Din,Dout) :- New is Num - 1,
  111.             append(Din,[45],Dmid),
  112.             dashes(New,Dmid,Dout). 
  113.  
  114. cont(32,Chars,Din,Dout) :- !,dashes(Chars,Din,Dout).
  115.             /* if ' ' append char dashes */
  116.                 
  117.             
  118. cont(End,Chars,Din,Dout) :-     New is Chars - 1,
  119.                 ifs(End,Din,Dmid),
  120.                 spaces(New,Dmid,Dmid1),
  121.                 append(Dmid1,[43],Dout).
  122.  
  123.                 /* if [] add char - 1 spaces and +
  124.                 if + append + and char - 1 spaces and +    
  125.                 if | append | and char - 1 spaces and +
  126.                 if anything else, I messed up */
  127.  
  128. aux_cross(Din,Dout,Chars) :-     end(Din,Dmid1,End),
  129.                 cont(End,Chars,Dmid1,Dmid2),
  130.             /* since we are in a --- always end with a ' ' */
  131.                 append(Dmid2,[32],Dout).
  132.  
  133. choose(32,Din,Dout) :- append(Din,[43],Dout).
  134. choose(End,Din,Dout) :-  ifs(End,Din,Dout).
  135.  
  136. check(In) :- In>0,!.
  137. check(In) :- In=<0,write('Error: label overlap detected; suggest increasing base node seperation in loc'),nl, fail.
  138.                         
  139. breadth(Max,Max,_) :- !.
  140. breadth(Level,Max,Struct) :-
  141.             New is Level + 1,
  142.             at(Level,1,Struct,0,_,[],Out,[],Tout,[],Dout), 
  143.             /* print dashes, nl, text, nl, lines, nl */
  144.             post(Level,Dout), nl,
  145.              prt(Tout), nl,
  146.              aux_lines(Out,0,New,Max),nl,
  147.             breadth(New,Max,Struct).
  148.  
  149. at(1,Arity,Struct,Cur,Pos,In,Out,Tin,Tout,Din,Dout) :- !,
  150.             functor(Struct,Name,_),
  151.             arg(1,Struct,Spaces), 
  152.             Actual is Spaces - Cur,
  153.             check(Actual), 
  154.             spaces(Actual,Tin,Tmid),
  155.             T is Cur + Actual,
  156.             size(Name,Size), Pos is T + Size,
  157.             M is (Size+1)/2, trunc(M,V),
  158.             L is T + V - 1,
  159.             len(Din,Len),
  160.             Chars_needed is ((L + 1) - Len),
  161.             cross(Arity,Din,Dout,Chars_needed),
  162.             append(In,[L],Out),
  163.             dummy(Name,Tmid,Tout).
  164.  
  165.  
  166. at(Level,_,Struct,Cur,Pos,In,Out,Tin,Tout,Din,Dout) :- 
  167.                 functor(Struct,_,Arity),
  168.                 Next_lev is Level - 1,
  169.     for_each(1,Arity,Struct,Next_lev,Cur,Pos,In,Out,Tin,Tout,Din,Dout).
  170.  
  171. for_each(Same,Same,_,_,X,X,Y,Y,Z,Z,Din,Dout) :- !, end(Din,Mid,End),
  172.                         choose(End,Mid,Dout).
  173.                     /* if End is ' ' then append '+'
  174.                     else append End */
  175.  
  176. for_each(Begin,End,Struct,Level,Cur,New_Pos,In,Out,Tin,Tout,Din,Dout) :-
  177.                 Count is Begin + 1, 
  178.                 arg(Count,Struct,Sub),
  179.             at(Level,End,Sub,Cur,Pos,In,Mid,Tin,TMid,Din,Dmid),
  180.       for_each(Count,End,Struct,Level,Pos,New_Pos,Mid,Out,TMid,Tout,Dmid,Dout).
  181.  
  182. /* ------ end draw  ------------- max depth begin --------------------------*/
  183.  
  184. md(Level,Struct,Cur,Level) :- functor(Struct,_,0), Level >= Cur, !.
  185. md(Level,Struct,Cur,Cur) :- functor(Struct,_,0), Cur < Level, !.
  186.  
  187. md(Level,Struct,Cur,Max) :- functor(Struct,_,Arity),
  188.                 Next is Level + 1,
  189.                 foreach(0,Arity,Struct,Cur,Max,Next).
  190.  
  191. foreach(Same,Same,_,Max,Max,_) :- !.
  192.  
  193. foreach(Begin,End,Struct,Cur,Max,Level) :- Count is Begin + 1,
  194.                     arg(Count,Struct,Sub),
  195.                     md(Level,Sub,Cur,Cmax),
  196.                         foreach(Count,End,Struct,Cmax,Max,Level).
  197. /*--- max depth end ----------------------------------------------------------*/
  198.  
  199. /* the 4 in "New is (Cur + Size) + 4" below is the spacing between base nodes
  200.    of the tree.  If you are having label overlap problems, increase it and
  201.    they might go away */
  202.  
  203. loc(Struct,Cur,New,New_struct,Adj) :-   size(Struct,Size), 
  204.                     New is (Cur + Size) + 4,
  205.                     functor(Struct,Name,Arity),
  206.                     NArity is Arity + 1,
  207.                     functor(New_struct,Name,NArity),
  208.                     M is (Size + 1)/2, trunc(M,V), 
  209.                     Adj is Cur + (V - 1). 
  210.  
  211. al(0,Struct,New_struct,Cur,New,Adj) :- loc(Struct,Cur,New,New_struct,Adj),
  212.                     arg(1,New_struct,Cur).
  213.  
  214. /* everytime I get to bottom of branch, and level is not equal to maxdepth,
  215.    add a level */
  216.  
  217. al(Needed_Depth,Struct,New_struct,Cur,Npos,Adj)  :- New is Needed_Depth - 1, 
  218.                     al(New,Struct,Tstruct,Cur,Npos,Adj),
  219.                     functor(New_struct,'~',2),
  220.                         arg(2,New_struct,Tstruct),
  221.                     arg(1,New_struct,Adj).
  222.  
  223. /* this is the case where we are at the leaf and it is the right depth */
  224.  
  225. add(1,Struct,New_struct,Cur,New) :- !,
  226.                     loc(Struct,Cur,New,New_struct,_),
  227.                     arg(1,New_struct,Cur).
  228.  
  229. /* this is the case where the leaf is not deep enough (add dummys) */
  230. add(Depth,Struct,New_struct,Cur,New)  :- functor(Struct,_,0),!,
  231.                 Next is Depth - 1,
  232.                 /* insert add dummy structs here and return
  233.                    the result as New_struct */
  234.                                 al(Next,Struct,New_struct,Cur,New,_).
  235.  
  236. add(Depth,Struct,New_struct,Cur,New) :- functor(Struct,_,Arity),
  237.                 Next is Depth - 1, 
  238.             fore(0,Arity,Struct,Next,New_struct,Cur,New,_,_).
  239.  
  240. fore(Same,Same,Struct,_,New_struct,Cur,Cur,First,Size) :- !,
  241.                         functor(Struct,Name,Arity), 
  242.                         NArity is Arity + 1,
  243.                         functor(New_struct,Name,NArity),
  244. /*the pos of this struct is (first + cur)/2 or first depending on single
  245.   or multiple sub structures */
  246.                         size(Name,Nsize),
  247.                     case(Same,Cur,Size,First,Pos,Nsize),
  248.                          arg(1,New_struct,Pos).
  249.  
  250. fore(Begin,End,Struct,Cur_depth,New_struct,Cur,New,Ifst,Isize) :- 
  251.                         Count is Begin + 1,
  252.                         arg(Count,Struct,Sub),
  253.                     add(Cur_depth,Sub,Sub1,Cur,Mid),
  254.                         arg(1,Sub1,Spos),
  255.                         functor(Sub1,Name,_),
  256.                         size(Name,Nsize),
  257.                 first(Count,Spos,Isize,Nsize,Size,Ifst,First),
  258.     fore(Count,End,Struct,Cur_depth,New_struct,Mid,New,First,Size),
  259.                         Newcount is Count + 1,
  260.                         arg(Newcount,New_struct,Sub1).
  261.  
  262. first(1,Cur,_,Size,Size,_,Cur) :-!.
  263. first(_,_,Size,_,Size,Same,Same).
  264.  
  265. /* single or multiple subargs; if End is 1, then single, else multiple */ 
  266.  
  267. case(1,_,Size,First,Pos,Nsize) :- !,T is First + ((Size+1)/2),
  268.                 trunc(T,V), Mid is V - 1, 
  269.                 T2 is ((Nsize+1)/2) - 1,
  270.                 trunc(T2,T3),
  271.                 Pos is Mid - T3.
  272.  
  273. case(_,Cur,_,First,Pos,_) :- Temp is ((Cur - 4) + First + 1)/2,
  274.             trunc(Temp,V), Pos is V - 1.
  275.  
  276.